#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#

#|
A command-line interface for clack:clackup.
|#

(ql:quickload '(:uiop :split-sequence) :silent t)

(import 'split-sequence:split-sequence)

(defun help ()
  (format t "~&Usage:
    # run the .lisp file
    ~A hello.lisp

    # switch server handler with --server
    ~:*~A --server :wookie --port 8080 hello.lisp

The .lisp file is a Common Lisp file which ends with a form
that returns a Clack application, typically LAMBDA.

Options:
    --server
        Selects a specific server handler to run on.
        The value has to be a keyword like \":wookie\".

    --address
        Binds to a TCP interface. Defaults to 127.0.0.1. This option is only valid for servers which support TCP sockets.

    --port
        Binds to a TCP port. Defaults to 5000.

    --swank-interface
    --swank-port
        Runs Swank server.

    --use-default-middlewares
        A flag if use default middlewares. The default is T.
        Specify NIL for preventing from loading those middlewares.

    -S, --source-registry
        Append ASDF source registry to the default.
        (Unlike Roswell's, this doesn't override it)

    -s, --system
        Load systems.

    -l, --load
        Load a file before starting a server.

    --help
        Shows this message.
"
          (read-from-string
           (second (assoc "script"
                          (let ((*read-eval*))
                            (read-from-string (uiop:getenv "ROS_OPTS")))
                          :test 'equal)))))

;; Prevent a symbol conflict with CCL:TERMINATE.
(defun %terminate (code &optional message args)
  (when message
    (format *error-output* "~&Error: ~A~%"
            (apply #'format nil (princ-to-string message) args)))
  (uiop:quit code))

(defun starts-with (x starts)
  (and (<= (length starts) (length x))
       (string= x starts :end1 (length starts))))

(defun parse-args (args)
  (flet ((parse-value (value)
           (handler-case
               (let ((read-value (read-from-string value)))
                 (typecase read-value
                   (boolean read-value)
                   ((and symbol (not keyword)) value)
                   (otherwise read-value)))
             (error ()
               value))))
    (loop with app-file = nil
          for option = (pop args)
          for value = (pop args)
          while option
          if (or (string= option "--source-registry")
                 (string= option "-S"))
            append (list :source-registry value)
              into opt-args
          else if (or (string= option "--system")
                      (string= option "-s"))
                 collect value into load-systems
          else if (or (string= option "--load")
                      (string= option "-l"))
                 collect value into load-files
          else if (not (starts-with option "--"))
            do (if app-file
                   (error "Invalid option: ~S" option)
                   (progn
                     (setf app-file option)
                     (push value args)))
          else if (string-equal option "--server")
                 append (list :server
                              (let ((parsed (parse-value value)))
                                (if (keywordp parsed)
                                    parsed
                                    (intern (string-upcase value) :keyword))))
                   into key-args
          else
            append (list (intern (string-upcase (subseq option 2)) :keyword)
                         (parse-value value))
              into key-args
          finally
             (return (values app-file key-args
                             (list* :load load-files :systems load-systems opt-args))))))

(defun parse-server-starter-port ()
  (flet ((parse-host-port (host-port)
           (parse-integer
            (let ((colon-pos (position #\: host-port)))
              (if colon-pos
                  (subseq host-port (1+ colon-pos))
                  host-port)))))
    (let ((ss-ports (uiop:getenv "SERVER_STARTER_PORT")))
      (when (stringp ss-ports)
        (destructuring-bind (host-port fd)
            (split-sequence #\=
                            ;; Assuming the first binding is for the Clack web server.
                            (car (split-sequence #\; ss-ports :count 1)))
          (values (parse-host-port host-port)
                  (parse-integer fd)))))))

(defun main (&rest args)
  (when (or (null args)
            (equal (first args) "--help"))
    (help)
    (uiop:quit -1))

  (ql:quickload :clack :silent t)

  (multiple-value-bind (app-file key-args opt-args)
      (parse-args args)
    (unless (probe-file app-file)
      (%terminate -1 "File doesn't exist: ~A" app-file))

    ;; Add ASDF source-registry
    (when (getf opt-args :source-registry)
      (asdf:compute-source-registry (truename (getf opt-args :source-registry))))

    ;; Load systems
    (mapc #'ql:quickload (getf opt-args :systems))

    ;; Load files
    (mapc #'load (getf opt-args :load))

    ;; Add :port and :fd from Server::Starter's environment var.
    (multiple-value-bind (port fd)
        (parse-server-starter-port)
      (when port
        (setf key-args (append key-args (list :port port :fd fd)))))

    ;; Disable threads
    (setf (getf key-args :use-thread) nil)

    ;; Disable debugger
    (setf (getf key-args :debug) nil)

    (apply (intern (string :clackup) :clack) app-file key-args)))
